{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module FRP.Taupo.Async (AsyncSignal, signal, event, output) where

import Data.Align (Semialign (align, alignWith))
import Data.Functor (void)
import Data.Functor.Combinator (HFunctor (hmap), Inject (inject))
import Data.Kind (Type)
import Data.These (These)

data AsyncSignal (eff :: Type -> Type) (a :: Type) where
  AsyncSignal :: (a -> eff b) -> AsyncSignal eff b
  AsyncTransform :: (a -> eff b) -> AsyncSignal eff a -> AsyncSignal eff b
  AsyncMux :: (These a b -> c) -> AsyncSignal eff a -> AsyncSignal eff b -> AsyncSignal eff c

instance (Functor eff) => Functor (AsyncSignal eff) where
  fmap f = \case
    AsyncSignal act -> AsyncSignal (fmap (fmap f) act)
    AsyncTransform g sig -> AsyncTransform (fmap f . g) sig
    AsyncMux g sig1 sig2 -> AsyncMux (f . g) sig1 sig2
  (<$) x = \case
    AsyncSignal act -> AsyncSignal ((x <$) . act)
    AsyncTransform g sig -> AsyncTransform ((x <$) . g) sig
    AsyncMux _ sig1 sig2 -> AsyncMux (const x) sig1 sig2

instance (Functor eff) => Semialign (AsyncSignal eff) where
  align sig1 sig2 = AsyncMux id sig1 sig2
  alignWith f sig1 sig2 = AsyncMux f sig1 sig2

instance HFunctor AsyncSignal where
  hmap nt = \case
    AsyncSignal act -> AsyncSignal (fmap nt act)
    AsyncTransform g sig -> AsyncTransform (nt . g) (hmap nt sig)
    AsyncMux g sig1 sig2 -> AsyncMux g (hmap nt sig1) (hmap nt sig2)

instance Inject AsyncSignal where
  inject = AsyncSignal . const

signal :: (Functor eff) => (a -> eff ()) -> AsyncSignal eff a
signal act = AsyncSignal (\x -> x <$ act x)

event :: (Functor eff) => (a -> eff ()) -> AsyncSignal eff a -> AsyncSignal eff a
event f = AsyncTransform (\x -> x <$ f x)

output :: (Functor eff) => (a -> eff b) -> AsyncSignal eff a -> AsyncSignal eff ()
output f = AsyncTransform (void . f)
